SWAGOLX.EXE (c) 1993 GDSOFT ALL RIGHTS RESERVED 00012 1 08-24-9413:32ALL KEN BURROWS Duplicate File/String SWAG9408 !╖û 16 ╙═ {π MG> Trying to figure out the fastest wayπ MG> to find and delete duplicate strings,π MG> which are actually file names in anπ MG> ASCII file.ππUsing the strings and objects unit, pstringcollections can be used to sort andπtest for dupes quite easilly.π}ππUses Objects,Strings,Dos;ππConstπ inFile : String = '';π OutFile : String = '';π DupFile : String = '';ππTypeπ NewPCol = Object(TStringCollection)π function compare(key1,key2:pointer):integer; virtual;π end;π PSColl = ^NewPCol;ππFunction NewPCol.Compare(key1,key2:pointer):integer;π Beginπ Compare := StrIComp(key1,key2);π End;ππProcedure Doit;π Var NewLst,π DupLst : PSColl;π s : string;π ps : pstring;π f : text;π i : integer;π Procedure WriteEm(pst:Pstring); far;π beginπ writeln(f,pst^);π end;π Beginπ New(NewLst,init(5,5));π New(DupLst,init(5,5));π DupLst^.Duplicates := true;π assign(f,InFile); reset(f);π While not Eof(f) doπ Beginπ readln(f,s);π if s <> ''π then beginπ ps := newstr(s);π i := NewLst^.Count;π NewLst^.insert(ps);π if i = NewLst^.Count then DupLst^.insert(ps);π end;π End;π close(f);π if NewLst^.count > 0π then beginπ assign(f,OutFile); rewrite(f);π NewLst^.forEach(@WriteEm);π close(f);π end;π if DupLst^.Count > 0π then beginπ assign(f,DupFile); rewrite(f);π DupLst^.forEach(@WriteEm);π close(f);π end;π dispose(DupLst,done);π dispose(NewLst,Done);π End;ππBeginπ if paramcount < 2 then halt;π InFile := paramstr(1);π OutFile := paramstr(2);π DupFile := OutFile;π Dec(DupFile[0],3);π DupFile := DupFile + 'DUP';π if DupFile = OutFile then halt;π Doit;πEnd.ππ 2 08-24-9413:44ALL SWAG SUPPORT TEAM Example of LINKED RecordsSWAG9408 εε╒ 35 ╙═ program LinkLst2;ππusesπ Crt;ππconstπ FileName = 'LinkExp.dta';ππtypeπ PMyNode = ^TMyNode;π TMyNode = recordπ Name : String;π Flight: integer;π Day : String;π Next : PMyNode; {Used to link each field}π end;ππprocedure CreateNew(var Item: PMyNode);πbeginπ New(Item);π Item^.Next := nil;π Item^.Name := '';π Item^.Flight := 0;π Item^.Day := '';πend;ππprocedure GetData(var Item: PMyNode);πbeginπ ClrScr;π repeatπ GotoXY(1, 1);π Write('Enter Name: ');π Read(Item^.Name);π until (Item^.Name <> '');π GotoXY(1, 2);π Write('Enter Flight number: ');π ReadLn(Item^.Flight);π GotoXY(1, 3);π Write('Enter Day: ');π ReadLn(Item^.Day);πend;ππprocedure DoFirst(var First, Current: PMyNode);πbeginπ CreateNew(Current);π GetData(Current);π First := Current;πend;ππprocedure Add(var Prev, Current: PMyNode);πbeginπ Prev := Current;π CreateNew(Current);π GetData(Current);π Prev^.Next := Current;πend;ππprocedure DeleteNode(var Head, Node, Current: PMyNode);πvarπ Temp: PMyNode;πbeginπ Temp := Head;π while Temp^.Next <> Node doπ Temp := Temp^.Next;π if Temp^.Next^.Next <> nil thenπ Temp^.Next := Temp^.Next^.Nextπ else beginπ Temp^.Next := nil;π Current := Temp;π end;π Dispose(Node);πend;ππfunction Find(Head: PMyNode; S: String): PMyNode;πvarπ Temp: PMyNode;πbeginπ Temp := nil;π while Head^.Next <> nil do beginπ if Head^.Name = S then beginπ Temp := Head;π break;π end;π Head := Head^.Next;π end;π if Head^.Name = S then Temp := Head;π Find := Temp;πend;ππprocedure DoDelete(var Head, Current: PMyNode);πvarπ S: String;π Temp: PMyNode;πbeginπ ClrScr;π Write('Enter name from record to delete: ');π ReadLn(S);π Temp := Find(Head, S);π if Temp <> nil thenπ DeleteNode(Head, Temp, Current);πend;ππprocedure ShowRec(Item: PMyNode; i: Integer);πbeginπ GotoXY(1, i); Write('Name: ', Item^.Name);π GotoXY(25, i); Write('Flight: ', Item^.Flight);π GotoXY(45, i); Write('Day: ', Item^.Day);πend;ππprocedure Show(Head: PMyNode);πvarπ i: Integer;πbeginπ i := 1;π ClrScr;π while Head^.Next <> nil do beginπ Head := Head^.Next;π ShowRec(Head, i);π Inc(i);π end;π WriteLn;π WriteLn('==========================================================');π WriteLn(i, ' records shown');π ReadLn;πend;ππprocedure FreeAll(var Head: PMyNode);πvarπ Temp: PMyNode;πbeginπ while Head^.Next <> nil do beginπ Temp := Head^.Next;π Dispose(Head);π Head := Temp;π end;π Dispose(Head);πend;ππprocedure CreateNewFile(Head: PMyNode);πvarπ F: File of TMyNode;πbeginπ Assign(F, FileName);π ReWrite(F);π while Head^.Next <> nil do beginπ Write(F, Head^);π Head := Head^.Next;π end;π Write(F, Head^);π Close(F);πend;ππprocedure ReadFile(var First, Prev, Current: PMyNode);πvarπ F: File of TMyNode;πbeginπ Assign(F, FileName);π Reset(F);π CreateNew(Current);π Read(F, Current^);π First := Current;π while not Eof(F) do beginπ Prev := Current;π CreateNew(Current);π Read(F, Current^);π Prev^.Next := Current;π end;π Close(F);πend;ππprocedure Main(var First, Prev, Current: PMyNode);πvarπ F : Text;πbeginπ {$I-}π Assign (f, 'HW2FILE.TXT');π Reset(f);π {$I+}π if (IOResult <> 0) then beginπ WriteLn('error Reading File');π Halt;π end;π CreateNew(Current);π ReadLn(F, Current^.Name);π ReadLn(F, Current^.Flight);π ReadLn(F, Current^.Day);π First := Current;π while not Eof(F) do beginπ Prev := Current;π CreateNew(Current);π ReadLn(F, Current^.Name);π ReadLn(F, Current^.Flight);π ReadLn(F, Current^.Day);π Prev^.Next := Current;π end;π Close(F);π Show(First);π CreateNewFile(First);πend;ππfunction WriteMenu: Char;πvarπ Ch: Char;πbeginπ ClrScr;π GotoXY(1, 1);π WriteLn('A) Add');π WriteLn('D) Delete');π WriteLn('S) Show');π WriteLn('W) Write File');π WriteLn('X) Exit');π repeatπ Ch := UpCase(ReadKey);π until Ch in ['A', 'D', 'S', 'W', 'X'];π WriteMenu := Ch;πend;ππvarπ Ch: Char;π First,π Prev,π Current: PMyNode;ππbeginπ ClrScr;π { Main(First, Prev, Current); Use this option to read text file }π ReadFile(First, Prev, Current);π repeatπ Ch := WriteMenu;π case Ch ofπ 'A': Add(Prev, Current);π 'D': DoDelete(First, Current);π 'S': Show(First);π 'W': CreateNewFile(First);π end;π until Ch = 'X';πend.πend. { main program}π 3 08-24-9413:45ALL SWAG SUPPORT TEAM Linked List Routine SWAG9408 UJ╒ 12 ╙═ typeπ PDataRec = ^TDataRec;π TDataRec = recordπ Name: String;π Next: PDataRec;π end;ππconstπ DataRecList: PDataRec = nil;π CurRec :PDataRec = nil;ππprocedure AddRec(AName: String);πvar Temp: PDataRec;πbeginπ New(CurRec);π CurRec^.Name := AName;π CurRec^.Next := nil;π Temp := DataRecList;π if Temp = nil thenπ DataRecList := CurRecπ elseπ beginπ while Temp^.Next <> nil do Temp := Temp^.Next;π Temp^.Next := CurRec;π end;πend;ππprocedure PrevRec;πvar Temp: PDataRec;πbeginπ Temp := DataRecList;π if Temp <> CurRec thenπ while Temp^.Next <> CurRec do Temp := Temp^.Next;π CurRec := Temp;πend;ππprocedure NextRec;πbeginπ if CurRec^.Next <> nil then CurRec := CurRec^.Next;πend;ππprocedure List;πvar Temp: PDataRec;πbeginπ Temp := DataRecList;π while Temp <> nil doπ beginπ Write(Temp^.Name);π if Temp = CurRec thenπ Writeln(' <<Current Record>>')π elseπ Writeln;π Temp := Temp^.Next;π end;πend;ππbeginπ AddRec('Tom'); AddRec('Dick'); AddRec('Harry'); AddRec('Fred');π Writeln('Original List');π List;π Writeln;π Readln;ππ PrevRec; PrevRec;π Writeln('After Two PrevRec Calls');π List;π Writeln;π Readln;ππ NextRec;π Writeln('After One NextRec Call');π List;π Writeln;π Readln;ππ Writeln('End of Program.');πend. 4 08-24-9413:49ALL GUY MCLOUGHLIN Double Linked Lists SWAG9408 ╒@pÑ 39 ╙═ πprogram Demo_Doubly_Linked_List_Sort;ππconstπ co_MaxNode = 1000;ππtypeπ T_St15 = string[15];ππ T_PoNode = ^T_Node;ππ T_Node = recordπ Data : T_St15;π Next,π Prev : T_PoNodeπ end;ππ T_PoArNodes = ^T_ArNodePtrs;π T_ArNodePtrs = array[1..succ(co_MaxNode)] of T_PoNode;πππ function RandomString : {output}π T_St15;π varπ by_Index : byte;π st_Temp : T_St15;π beginπ st_Temp[0] := chr(succ(random(15)));π for by_Index := 1 to length(st_Temp) doπ st_Temp[by_Index] := chr(random(26) + 65);π RandomString := st_Tempπ end;ππ procedure AddNode({update}π varπ po_Node : T_PoNode);π beginπ if (maxavail > sizeof(T_Node)) thenπ beginπ new(po_Node^.Next);π po_Node^.Next^.Next := nil;π po_Node^.Next^.Prev := po_Node;π po_Node^.Next^.Data := RandomStringπ endπ end;ππ procedure DisplayList({input}π po_Node : T_PoNode);π varπ po_Temp : T_PoNode;π beginπ po_Temp := po_Node;π repeatπ write(po_Temp^.Data:20);π po_Temp := po_Temp^.Nextπ until (po_Temp^.Next = nil);π write(po_Temp^.Data:20)π end;ππ procedure ShellSortNodes ({update}π varπ ar_Nodes : T_ArNodePtrs;π {input }π wo_NodeTotal : word);π varπ Temp : T_PoNode;π Index1,π Index2,π Index3 : word;π beginπ Index3 := 1;π repeatπ Index3 := succ(3 * Index3)π until (Index3 > wo_NodeTotal);π repeatπ Index3 := (Index3 div 3);π for Index1 := succ(Index3) to wo_NodeTotal doπ beginπ Temp := ar_Nodes[Index1];π Index2 := Index1;π while (ar_Nodes[(Index2 - Index3)]^.Data > Temp^.Data) doπ beginπ ar_Nodes[Index2] := ar_Nodes[(Index2 - Index3)];π Index2 := (Index2 - Index3);π if (Index2 <= Index3) thenπ breakπ end;π ar_Nodes[Index2] := Tempπ endπ until (Index3 = 1)π end; (* ShellSortNodes. *)ππ procedure RebuildList({input }π varπ ar_Nodes : T_ArNodePtrs;π {update}π varπ po_Head : T_PoNode);π varπ wo_Index : word;π po_Current : T_PoNode;π beginπ wo_Index := 1;π po_Head := ar_Nodes[wo_Index];π po_Head^.Prev := nil;π po_Head^.Next := ar_Nodes[succ(wo_Index)];π po_Current := po_Head;π repeatπ inc(wo_Index);π po_Current := po_Current^.Next;π po_Current^.Next := ar_Nodes[succ(wo_Index)];π po_Current^.Prev := ar_Nodes[pred(wo_Index)]π until (ar_Nodes[succ(wo_Index)] = nil)π end;ππvarπ wo_Index : word;ππ po_Heap : pointer;ππ po_Head,π po_Current : T_PoNode;ππ po_NodeArray : T_PoArNodes;ππBEGINπ (* Initialize pseudo-random number generator. *)π randomize;ππ (* Mark initial HEAP state. *)π mark(po_Heap);ππ (* Initialize list head node. *)π new(po_Head);π with po_Head^ doπ beginπ Next := nil;π Prev := nil;π Data := RandomStringπ end;ππ (* Create doubly linked list of random strings. *)π po_Current := po_Head;π for wo_Index := 1 to co_MaxNode doπ beginπ AddNode(po_Current);π if (wo_Index < co_MaxNode) thenπ po_Current := po_Current^.Nextπ end;ππ writeln('Total Nodes = ', wo_Index);π readln;ππ DisplayList(po_Head);π writeln;π writeln;ππ (* Allocate array of node pointers on the HEAP. *)π if (maxavail > sizeof(T_ArNodePtrs)) thenπ new(po_NodeArray);ππ (* Set them all to NIL. *)π fillchar(po_NodeArray^, sizeof(po_NodeArray^), 0);ππ (* Assign pointer in array to nodes. *)π wo_Index := 0;π po_Current := po_Head;π repeatπ inc(wo_Index);π po_NodeArray^[wo_Index] := po_Current;π po_Current := po_Current^.Nextπ until (po_Current^.Next = nil);ππ (* ShellSort the array of nodes. *)π ShellSortNodes(po_NodeArray^, wo_Index);ππ (* Re-build the doubly linked-list from array of nodes. *)π RebuildList(po_NodeArray^, po_Head);ππ (* Deallocate array of nodes. *)π dispose(po_NodeArray);ππ writeln;π writeln;π DisplayList(po_Head);ππ (* Release HEAP memory used. *)π release(po_Heap)ππEND.ππ 5 08-24-9413:49ALL MARK GAUTHIER OOP Linked Lists SWAG9408 ;¿y 70 ╙═ Unit MgLinked;ππinterfaceππconstππ { Error list. }π Succes = $00;π Need_Mem = $01;π Point_To_Nil = $02;ππtypeππ DoubleLstPtr = ^DoubleLst;π DoubleLst = recordπ Serial : longint;π Size : word;π Addresse : pointer;π Next : DoubleLstPtr;π Previous : DoubleLstPtr;π end;πππ PDoubleLst = ^ODoubleLst;π ODoubleLst = objectππ privateπ LastCodeErr : word; {-- Last error. --}ππ publicπ TotalObj : longint; {-- Total obj allocate. --}π CurentObj : DoubleLstPtr; {-- Curent obj number. --}ππ constructor Init(var Install:boolean; Serial:longint; Size:word;πData:pointer);π {-- Initialise all variables, new curent. ---}ππ destructor Done;ππ {--- get and clear the last err. ---}π function LastError:word;ππ {--- Seek to end and add an object. ---}π procedure Add(Size:word; Data:pointer);ππ {--- Change the size of data of a object. 0 = change curent. ---}π procedure ChangeSize(Serial:longint; NewSize : word);ππ {--- Insert an object before the curent obj. 0 = insert curent pos ---}π procedure Insert(Serial:longint; Size:word; Data:pointer);ππ {--- Delete an object from the list. 0 = delete curent. ---}π procedure Delete(Serial:longint);ππ {--- Pointe on next or end, etc. ---}π procedure SeekFirst;π procedure SeekLast;π procedure SeekNext;π procedure SeekPrevious;π procedure SeekNum(Serial:longint);ππ {--- Move data from obj to user buffer ---}π {--- 0 = use curent object. ---}π function MoveObjToPtr(Serial:longint; p:pointer):word;ππ {--- Move user buffer to obj data. obj data take ObjSize bytes ---}π {--- 0 = use curent object. ---}π function MovePtrToObj(Serial:longint; p:pointer):word;ππ end;ππimplementationππ(****************************************************************************)ππ procedure move(Src,Dst:pointer; Size:word);assembler;π asmπ lds si,Srcπ les di,Dstπ mov cx,Sizeπ cldπ rep movsbπ end;πππ(****************************************************************************)ππconstructor ODoubleLst.Init(var Install:boolean; Serial:longint; Size:word;πData:pointer);π{-- Initialise all variables, new curent. ---}πbeginπ Install := false;π if Serial = 0 then exit;π New(CurentObj);π if CurentObj = nil then exit;π GetMem(CurentObj^.Addresse, Size);π if CurentObj^.Addresse = nil thenπ beginπ LastCodeErr := Need_Mem;π exit;π end;ππ CurentObj^.Next := nil;π CurentObj^.Previous := nil;π CurentObj^.Size := Size;π CurentObj^.Serial := Serial;π move(Data, CurentObj^.Addresse, Size);ππ TotalObj := 1;ππ Install := true;π LastCodeErr := Succes;πend;ππ(****************************************************************************)ππdestructor ODoubleLst.Done;π{-- Initialise all variables, new curent. ---}πbeginπ repeat delete(0);π until (LastError <> Succes) or (TotalObj <= 0);πend;ππ(****************************************************************************)ππfunction ODoubleLst.LastError:word;π{--- get and clear the last err. ---}πbeginπ LastError := LastCodeErr;π LastCodeErr := 0;πend;ππ(****************************************************************************)ππprocedure ODoubleLst.Add(Size:word; Data:pointer);π{--- Seek to end and add an object. ---}πbeginπ repeat SeekNext until LastError <> Succes; { SeekEnd }ππ New(CurentObj^.Next);π if CurentObj^.Next = nil thenπ beginπ LastCodeErr := Need_Mem;π exit;π end;ππ GetMem(CurentObj^.Next^.Addresse, Size);π if CurentObj^.Next^.Addresse = nil thenπ beginπ LastCodeErr := Need_Mem;π exit;π end;ππ CurentObj^.Next^.Size := Size;ππ { Store information data. }π move(Data, CurentObj^.Next^.Addresse, Size);ππ { Increment the total number of reccords. }π inc(TotalObj);ππ CurentObj^.Next^.Next := nil;π CurentObj^.Next^.Previous := CurentObj;ππ LastCodeErr := Succes;πend;ππ(****************************************************************************)ππprocedure ODoubleLst.ChangeSize(Serial:longint; NewSize : word);π{--- Change the size of an object. ---}πvar p:pointer;πbeginπ getmem(p,NewSize);π if p = nil thenπ beginπ LastCodeErr := Need_mem;π exit;π end;π SeekNum(Serial);π move(CurentObj^.Addresse, p, NewSize);π freemem(CurentObj^.Addresse, CurentObj^.Size);π CurentObj^.Size := NewSize;π CurentObj^.Addresse := p;π LastCodeErr := Succes;πend;ππ(****************************************************************************)ππprocedure ODoubleLst.Insert(Serial:longint; Size:word; Data:pointer);π{--- Insert an object before the curent obj. ---}πVar n:DoubleLstPtr;πbeginπ new(n);π if n = nil thenπ beginπ LastCodeErr := Need_mem;π exit;π end;π SeekNum(Serial);π getmem(n^.Addresse, Size);π if n^.Addresse = nil thenπ beginπ LastCodeErr := Need_mem;π exit;π end;ππ n^.Size := Size;π move(Data, n^.Addresse, Size);ππ n^.Previous := CurentObj^.Previous;π n^.Next := CurentObj;ππ CurentObj^.Previous^.Next := n;π CurentObj^.Previous := n;ππ inc(TotalObj);πend;ππ(****************************************************************************)ππprocedure ODoubleLst.Delete(Serial:longint);π{--- Delete an object from the list. ---}πbeginπ SeekNum(Serial);π if CurentObj^.Addresse <> nil thenπ beginπ FreeMem(CurentObj^.Addresse,CurentObj^.Size);π CurentObj^.Addresse := nil;π end;ππ CurentObj^.Next^.Previous := CurentObj^.Previous;π CurentObj^.Previous^.Next := CurentObj^.Next;ππ if CurentObj <> nil then Dispose(CurentObj);π CurentObj := CurentObj^.Previous;ππ dec(TotalObj);πend;ππ(****************************************************************************)ππprocedure ODoubleLst.SeekLast;πbeginπ repeat SeekNext until LastError <> Succes;πend;ππ(****************************************************************************)ππprocedure ODoubleLst.SeekFirst;πbeginπ repeat SeekPrevious until LastError <> Succes;πend;ππ(****************************************************************************)ππprocedure ODoubleLst.SeekNext;πbeginπ if CurentObj^.Next = nil thenπ beginπ LastCodeErr := Point_To_Nil;π exit;π end;π CurentObj := CurentObj^.Next;π LastCodeErr := Succes;πend;ππ(****************************************************************************)ππprocedure ODoubleLst.SeekPrevious;πbeginπ if CurentObj^.Previous = nil thenπ beginπ LastCodeErr := Point_To_Nil;π exit;π end;π CurentObj := CurentObj^.Previous;π LastCodeErr := Succes;πend;ππ(****************************************************************************)ππprocedure ODoubleLst.SeekNum(Serial:longint);πbeginπ if Serial = 0 then exit;π SeekFirst;π repeatππ SeekNext;ππ if CurentObj^.Serial = Serial thenπ beginπ LastCodeErr := Succes;π break;π end;ππ if LastError <> Succes thenπ beginπ LastCodeErr := Point_To_Nil;π break;π endπ else continue;ππ until false;ππend;ππ(****************************************************************************)ππfunction ODoubleLst.MoveObjToPtr(Serial:longint; p:pointer):word;π{--- Move data from obj to user buffer ---}πbeginπ SeekNum(Serial);π if (CurentObj^.Addresse = nil) or (p = nil) thenπ beginπ LastCodeErr := Point_To_Nil;π exit;π end;π move(CurentObj^.Addresse, p, CurentObj^.Size);π LastCodeErr := Succes;π MoveObjToPtr := CurentObj^.Size;πend;πππ(****************************************************************************)ππfunction ODoubleLst.MovePtrToObj(Serial:longint; p:pointer):word;π{--- Move user buffer to obj data. obj data take ObjSize bytes ---}πbeginπ SeekNum(Serial);π if (CurentObj^.Addresse = nil) or (p = nil) thenπ beginπ LastCodeErr := Point_To_Nil;π exit;π end;π move(p, CurentObj^.Addresse, CurentObj^.Size);π LastCodeErr := Succes;π MovePtrToObj := CurentObj^.Size;πend;πππend.π 6 08-24-9413:50ALL MARIUS ELLEN Pointers SWAG9408 K┤+█ 13 ╙═ {πDVE>> What I want to do is to make it point to the next byte in memory,πDVE>> sort of "apointer:=[byte ptr] apointer + 1"πDVE>> Apointer:=ptr(seg(apointer^),Ofs(apointer^) + 1);ππAGB> That won't work if the pointer is equal to 0FFFFh (Segment must beπAGB> adjusted!). A shorter (and faster?) method of coding this (wrong) way :πAGB> Inc(LongInt(APointer));ππOeps, this doesn't work either, especially in the case $ffff ! (unwantedπparagraph increase and in protected mode a RunTime Error 216 "Generalπprotection fault")ππFor non segm. overrides this should work fine: Aptr:=pchar(Aptr)+1;πand if youre planning segments overrides than you should use this:π}ππfunction GetDosPtr(Point:Pointer;Offs:Longint):pointer;πassembler;{offs in [$0..$fffff}πasmπ mov dx,point.word[2]π mov cx,offs.word[2]π mov bx,offs.word[0]π add bx,point.word[0]π adc cx,0π mov ax,bxπ and ax,0fhπ shr cx,1;rcr bx,1π shr cx,1;rcr bx,1π shr cx,1;rcr bx,1π shr cx,1;rcr bx,1π add dx,bxπend;ππ{And for protected mode: }ππfunction GetPtr(BASE:Pointer;Offs:Longint):Pbyte;πassembler;πasmπ MOV AX,word ptr [OFFS+2]π MOV BX,word ptr [OFFS+0]π ADD BX,word ptr [BASE+0]π ADC AX,0π MUL SelectorIncπ ADD AX,word ptr [BASE+2]π MOV DX,AXπ MOV AX,BXπend;π 7 08-24-9413:58ALL MARK GAUTHIER Match Strings in Array SWAG9408 1}₧M 44 ╙═ π{* Stack Research string for turbo pascal unit *}π{* Public Domain, 21/07/94 by Mark Gauthier. *}π{* Fidonet 1:242/818.5, FM 101:190/805.5 *}ππUnit Search;ππ{ What for?, it use stack function to search for a matching stringπ in an array. }ππInterfaceππConstππ MaxString : Word = 4096;π MaxStack : Word = 500;ππVarπ StrAddr : Array[1..4096] of Pointer;π { Addresse for all strings. }ππ TotalStr : Word;π { Curent strings number }ππ StrFreq : Array[1..4096] of Word;π { Search frequence for each string }ππ procedure ClearAllStack;π { Clear stack. You must call this procedure to tell unitπ you will change the searchstring. }ππ procedure AddString (S:String);π { Add a string in array, only if totalstr if < maxstring. }ππ function SearchString (S:String) : boolean;π { Search for a string, if stack is not clear previous search asπ been made. Example: you search for 'ABC' and this functionπ return true. If you search for 'ABCD' then this functionπ will go in stack and get all the old addr for 'ABC' and seeπ if 'D' is the next letter for the check strings.ππ * This unit is usefull to build compression unit.π }ππimplementationππVarπ SearchStr : Pointer;π LastFound : Word;π CurentStack : Byte;π StackPos : Array[1..2] of Word;π StackData : Array[1..2,1..500] of Word;ππ{*===================================================================*}ππ{ Return true is stack is empty }πfunction StackIsEmpty:boolean;πbeginπ StackIsEmpty := false;π if StackPos[CurentStack] = 0 then StackIsEmpty := true;πend;ππ{*===================================================================*}ππ{ Pop an element from stack }πfunction MgPop:Word;πbeginπ MgPop := 0;π If Not StackIsEmpty thenπ beginπ MgPop := StackData[CurentStack, StackPos[CurentStack]];π Dec(StackPos[CurentStack]);π end;πend;ππ{*===================================================================*}ππ{ Push an element on stack }πprocedure MgPush(Number:word);πvar x:byte;πbeginπ if CurentStack = 1 then x := 2 else x := 1;π If StackPos[x] < MaxStack thenπ beginπ Inc(StackPos[x]);π StackData[x, StackPos[x]] := Number;π end;πend;ππ{*===================================================================*}ππ{ Clear the curent stack }πprocedure ClearStack;πbeginπ StackPos[CurentStack] := 0;πend;ππ{*===================================================================*}ππ{ Inverse pop and push stack }πprocedure InverseStack;πbeginπ ClearStack;π If CurentStack = 1 then CurentStack := 2 else CurentStack := 1;πend;ππ{*===================================================================*}ππ{ Compare SearchStr(global var) and DATA(parameter) }π{$F+}πfunction Compare(Data:Pointer):boolean;assembler;πasmπ push bpπ mov bp,spππ push dsππ lds si,SearchStrπ lodsbπ mov cl,alπ mov ch,0ππ les di,[Bp+8]π inc diππ mov al,0π cldπ repe cmpsbπ jne @NotMatchπ mov al,1ππ@NotMatch:ππ pop dsπ pop bpπend;π{$F-}ππ{*===================================================================*}ππ{ Search procedure execute this procedure if stack is not empty. }πfunction SearchWhitPop:boolean;πVar Start : Word;πbeginπ SearchWhitPop := false;π While not StackIsEmpty doπ beginπ Start := MgPop;π if Compare(StrAddr[Start]) thenπ beginπ LastFound := Start;π SearchWhitPop := true;π MgPush(Start);π Inc(StrFreq[Start]);π end;π end;π InverseStack;πend;ππ{*===================================================================*}ππ{ Search procedure execute this procedure if stack is empty. }πfunction CompleteSearchPush:boolean;πvar i : word;πbeginπ CompleteSearchPush := false;π For i := 1 to TotalStr doπ beginπ if Compare(StrAddr[i]) thenπ beginπ LastFound := i;π CompleteSearchPush := true;π MgPush(i);π Inc(StrFreq[i]);π end;π end;π InverseStack;πend;ππ{*===================================================================*}ππ{ Public Search routine }πfunction SearchString(S:String):boolean;πbeginπ SearchStr := Addr(S);π If StackIsEmptyπ then SearchString := CompleteSearchPushπ else SearchString := SearchWhitPop;πend;ππ{*===================================================================*}ππ{ Add a string in heap }πprocedure AddString(S:String);πbeginπ Inc(TotalStr);π GetMem(StrAddr[TotalStr], Length(S));π Move(S,StrAddr[TotalStr]^, Length(S)+1);πend;ππ{*===================================================================*}ππ{ Clear pop and push stack }πprocedure ClearAllStack;πbeginπ InverseStack;π ClearStack;πend;ππ{*===================================================================*}ππ{ Unit Initialisation }πvar i : word;πBeginπ TotalStr := 0;π CurentStack := 0;π StackPos[1] := 0;π StackPos[2] := 0;π for i := 1 to 4096 do StrFreq[i] := 0;πEnd.π 8 08-24-9413:59ALL SWAG SUPPORT TEAM Nth array item in BASM SWAG9408 Å$▒≡ 5 ╙═ {πCC> I want to know how to retrieve the n(th) element from theπCC> table in BASM.ππSolution:π}ππ program _getvalue;ππ const table:array[0..9] of integer=π (1001,1002,1003,1004,1005,1006,1007,1008,1009,1010);ππ function getvalue(nth:word):integer; assembler;π asmπ mov si,nth { get index }π add si,si { 'multiply' by two (word-sized) }π mov ax,word ptr table[si] { put table[index] in ax -> function-result }π end;ππ beginπ writeln(getvalue(7));π end.π 9 08-24-9414:00ALL MATT BOUSEK Avl Tree Tally SWAG9408 ┐╚_ 59 ╙═ (*πHere is TALLY.PAS, a program that Matt Bousek <MBOUSEK@intel9.intel.com> wroteπto do a word frequency analysis on a text file. It uses an AVL tree. Itπshould compile under TP 6.0 or BP 7.0π*)πprogram word_freq(input,output);ππtypeπ short_str = string[32];ππ{************AVLtree routines*********}πtypeπ balance_set = (left_tilt,neutral,right_tilt);π memptr = ^memrec;π memrec = recordπ balance : balance_set;π left,right : memptr;π count : longint;π key : short_str;π end;ππ {**************************************}π procedure rotate_right(var root:memptr);π var ptr2,ptr3 : memptr;π beginπ ptr2:=root^.right;π if ptr2^.balance=right_tilt then beginπ root^.right:=ptr2^.left;π ptr2^.left:=root;π root^.balance:=neutral;π root:=ptr2;π end else beginπ ptr3:=ptr2^.left;π ptr2^.left:=ptr3^.right;π ptr3^.right:=ptr2;π root^.right:=ptr3^.left;π ptr3^.left:=root;π if ptr3^.balance=left_tiltπ then ptr2^.balance:=right_tiltπ else ptr2^.balance:=neutral;π if ptr3^.balance=right_tiltπ then root^.balance:=left_tiltπ else root^.balance:=neutral;π root:=ptr3;π end;π root^.balance:=neutral;π end;ππ {*************************************}π procedure rotate_left(var root:memptr);π var ptr2,ptr3 : memptr;π beginπ ptr2:=root^.left;π if ptr2^.balance=left_tilt then beginπ root^.left:=ptr2^.right;π ptr2^.right:=root;π root^.balance:=neutral;π root:=ptr2;π end else beginπ ptr3:=ptr2^.right;π ptr2^.right:=ptr3^.left;π ptr3^.left:=ptr2;π root^.left:=ptr3^.right;π ptr3^.right:=root;π if ptr3^.balance=right_tiltπ then ptr2^.balance:=left_tiltπ else ptr2^.balance:=neutral;π if ptr3^.balance=left_tiltπ then root^.balance:=right_tiltπ else root^.balance:=neutral;π root:=ptr3;π end;π root^.balance:=neutral;π end;ππ {*****************************************************************}π procedure insert_mem(var root:memptr; x:short_str; var ok:boolean);π beginπ if root=nil then beginπ new(root);π with root^ do beginπ key:=x;π left:=nil;π right:=nil;π balance:=neutral;π count:=1;π end;π ok:=true;π end else beginπ if x=root^.key then beginπ ok:=false;π inc(root^.count);π end else beginπ if x<root^.key then beginπ insert_mem(root^.left,x,ok);π if ok then case root^.balance ofπ left_tilt : beginπ rotate_left(root);π ok:=false;π end;π neutral : root^.balance:=left_tilt;π right_tilt : beginπ root^.balance:=neutral;π ok:=false;π end;π end;π end else beginπ insert_mem(root^.right,x,ok);π if ok then case root^.balance ofπ left_tilt : beginπ root^.balance:=neutral;π ok:=false;π end;π neutral : root^.balance:=right_tilt;π right_tilt : beginπ rotate_right(root);π ok:=false;π end;π end;π end;π end;π end;π end;ππ {*****************************************************}π procedure insert_memtree(var root:memptr; x:short_str);π var ok:boolean;π beginπ ok:=false;π insert_mem(root,x,ok);π end;ππ {*********************************}π procedure dump_mem(var root:memptr);π beginπ if root<>nil then beginπ dump_mem(root^.left);π writeln(root^.count:5,' ',root^.key);π dump_mem(root^.right);π end;π end;πππ{MAIN***************************************************************}π{*** This program was written by Matt Bousek sometime in 1992. ***}π{*** The act of this posting over Internet makes the code public ***}π{*** domain, but it would be nice to keep this header. ***}π{*** The basic AVL routines came from a book called "Turbo Algo- ***}π{*** rythms", Sorry, I don't have the book here and I can't ***}π{*** remember the authors or publisher. Enjoy. And remember, ***}π{*** there is no free lunch... ***}ππconstπ wchars:set of char=['''','a'..'z'];ππvarπ i,j : word;π aword : short_str;π subject : text;π wstart,wend : word;π inword : boolean;π linecount : longint;π wordcount : longint;π buffer : array[1..10240] of char;π line : string;π filename : string;π tree : memptr;ππBEGINπ tree:=nil;ππ filename:=paramstr(1);π if filename='' then filename:='tally.pas';π assign(subject,filename);π settextbuf(subject,buffer);π reset(subject);ππ wordcount:=0;π linecount:=0;π while not eof(subject) do beginπ inc(linecount);π readln(subject,line);π wstart:=0; wend:=0;π for i:=1 to byte(line[0]) do beginπ if line[i] in ['A'..'Z'] then line[i]:=chr(ord(line[i])+32);π inword:=(line[i] in wchars);π if inword and (wstart=0) then wstart:=i;π if inword and (wstart>0) then wend:=i;π if not(inword) or (i=byte(line[0])) then beginπ if wend>wstart then beginπ aword:=copy(line,wstart,wend+1-wstart);π j:=byte(aword[0]);π if (aword[j]='''') and (j>2) then begin {lose trailing '}π aword:=copy(aword,1,j-1);π dec(wend);π dec(j);π end;π if (aword[1]='''') and (j>2) then begin {lose leading '}π aword:=copy(aword,2,j-1);π inc(wstart);π dec(j);π end;π if (j>2) and (aword[j-1]='''') and (aword[j]='s') thenπbegin {lose trailing 's}π aword:=copy(aword,1,j-2);π dec(wend,2);π dec(j,2);π end;π if (j>2) then beginπ inc(wordcount);π insert_memtree(tree,aword);π end;π end; { **if wend>wstart** }π wstart:=0; wend:=0;π end; { **if not(inword)** }π end; { **for byte(line[0])** }π end; { **while not eof** }ππdump_mem(tree);πwriteln(linecount,' lines, ',wordcount,' words.');πEND.π 10 08-25-9409:10ALL LEE BARKER Sorting Linked Lists SWAG9408 ╡à· 11 ╙═ {π│ I'm looking for a routine to swap two nodes in a doubleπ│ linked list or a complete sort.ππThere has been a thread on the TP conf area in CIS on quickπsorting a (double) linked list. To swap two nodes, remove one,πthen add it in where desired. Quick sample-π}ππtypeπ s5 = string[5];π ntp = ^nodetype;π nodetype = recordπ prv,nxt : ntp;π data : s5;π end;πconstπ nbr : array[0..9] of string[5] = ('ZERO','ONE','TWO',π 'THREE','FOUR','FIVE','SIX','SEVEN','EIGHT','NINE');πvarπ node,root : ntp;π i : integer;ππprocedure swap (var n1,n2 : ntp);π var n : ntp;π beginπ n := n1;π n1 := n2;π n2 := n;π end;ππprocedure addnode (var n1,n2 : ntp);π beginπ swap(n1^.nxt,n2^.prv^.nxt);π swap(n1^.prv,n2^.prv);π end;ππprocedure getnode(i:integer);π var n : ntp;π beginπ getmem(n,sizeof(nodetype));π n^.nxt := n;π n^.prv := n;π n^.data := nbr[i];π if root=nilπ then root := nπ else addnode(n,root);π end;ππbeginπ root := nil;π for i := 0 to 9 doπ beginπ getnode(i);π node := root;π writeln;π writeln('The linked now is-');π repeatπ writeln(node^.data);π node := node^.nxt;π until node = root;π end;πend.π 11 08-25-9409:11ALL DEAVON EDWARDS Stacks SWAG9408 τ "█ 76 ╙═ {πFrom: Deavon@sound.demon.co.uk (Deavon Edwards)ππI am having some problem with this program. I would like to modified it toπdo the following....π i). To simulate the operation of a queue (Last In First Out).π ii) To use a linked list instead of arrays(simulating a stack and queue).πIf anyone out there can help it would be greatly appreciated.ππ This program will simulate the operation of a stack and a queue with aπ 10 items maximum. It will give the user the opportunity to insert andπ delete items from the data structures, display the data on screen,π it on a printer, and save and load the data from a diskπ}ππPROGRAM StackSimulation(input, output);ππUSES CRT,DOS,PRINTER;ππVARπ Stack : ARRAY [1..10] OF STRING[20];π StackFull : BOOLEAN;π StackEmpty : BOOLEAN;π Pointer : INTEGER;π Choice : CHAR;ππ {*******************************************************************}ππPROCEDURE PressAKey;πBEGINππ WRITELN;π WRITELN;π WRITELN (' ************************************');π WRITELN (' *** PRESS RETURN TO CONTINUE ***');π WRITELN (' ************************************');π READLN;π CLRSCR;πEND;π {*******************************************************************}πPROCEDURE Jump_a_Line(Jump: INTEGER);πVARπ Skip : INTEGER;ππBEGINπ FOR Skip := 1 TO Jump DOπ WRITELN;πEND;π {*******************************************************************}ππProcedure Introduction; {Display an introduction message to user}π BEGINπ CLRSCR;π gotoxy (1,10);π Textcolor(Cyan);π writeln(' ********************************************************');π writeln(' ********************************************************');π writeln(' * *');π writeln(' * WELCOME TO STACK & QUEUE SIMULATION PROGRAM *');π writeln(' * *');π writeln(' ********************************************************');π writeln(' ********************************************************');π Jump_a_line(3);π DELAY (1000);π end;ππ {*******************************************************************}ππPROCEDURE Initialise (VAR StackFull, StackEmpty : BOOLEAN);ππBEGINπ CLRSCR;π gotoxy (1,10);π Jump_a_line(2);π WRITELN (' ******************************************************');π WRITELN (' THE STACK IS INITIALISING...........PLEASE WAIT.......');π WRITELN (' ******************************************************');π Jump_a_line(3);π SOUND (240);π DELAY (1000);π CLRSCR;π NOSOUND;π Pointer := 0;π StackFull := FALSE;π StackEmpty := TRUE;πEND;ππ {*******************************************************************}ππPROCEDURE Add (VAR StackFull, StackEmpty : BOOLEAN);πBEGINπ IF StackFull THENπ BEGINπ gotoxy (1,10);π Jump_a_line(2);π WRITELN ('************************************************************');π WRITELN ('** SORRY, THE STACK IS FULL, NO MORE DATA CAN BE ENTERED ***');π WRITELN ('************************************************************');π Jump_a_line(3);π PressAKey;π ENDπ ELSEπ BEGINπ INC (Pointer);π Jump_a_line(3);π WRITE ('PLEASE ENTER THE ITEM TO BE ADDED TO THE STACK :=> ');π READLN (Stack [Pointer]);π CLRSCR;π IF StackEmpty THEN StackEmpty := FALSE;π IF Pointer = 10 THEN StackFull := TRUE;π END;πEND;ππ {*******************************************************************}ππPROCEDURE Take (VAR StackFull, StackEmpty : BOOLEAN);πBEGINπ IF StackEmpty THENπ BEGINπ gotoxy (1,10);π Jump_a_line(3);π WRITELN (' *******************************************************');π WRITELN (' *** THE STACK IS EMPTY, NO MORE DATA CAN BE REMOVED ***');π WRITELN (' *******************************************************');π Jump_a_line(3);π PressAKey;π ENDπ ELSEπ BEGINπ gotoxy (1,10);π Jump_a_line(3);π WRITE ('THE FOLLOWING ITEM HAVE BEEN REMOVE FROM THE STACK :=> ');π WRITELN (Stack [Pointer]);π DEC (Pointer);π IF Pointer = 0 THEN StackEmpty := TRUE;π IF StackFull THEN StackFull := FALSE;π Jump_a_line(3);π PressAKey;π END;πEND;ππ {*******************************************************************}ππPROCEDURE Display_to_Screen (StackEmpty : BOOLEAN);πVARπ Counter : INTEGER;πBEGINπ CLRSCR;π GOTOXY (1,10);π IF StackEmpty THENπ WRITELN (' THE STACK IS CURRENTLY EMPTY ');π Jump_a_Line (3);π FOR Counter := 1 TO Pointer DOπ WRITELN (Counter:2 ,' ', Stack [Counter]);π Jump_a_Line(2);π PressAKey;πEND;ππ {*******************************************************************}πPROCEDURE Print_to_Printer (StackEmpty : BOOLEAN);πVARπ Counter : INTEGER;πBEGINπ CLRSCR;π GOTOXY (1,10);π {$I-}π WRITELN (lst,#0);π IF IORESULT <> 0 THENπ WRITELN (' >>>>>> PRINTING ERROR.......PRINTER OFF LINE <<<<<< ')π ELSEπ BEGINπ IF StackEmpty THENπ WRITELN ('THE STACK IS CURRENTLY EMPTY, THERE IS NO DATA TO BE PRINTED.')π ELSEπ WRITELN (' THE CONTENTS OF THE STACK IS PRINTING........');π FOR Counter := Pointer DOWNTO 1 DOπ WRITELN (Lst,Counter:2 ,' ', Stack [Counter]);π END;π {$I+}π PressAKey;πEND;πππ {****************************************************}ππPROCEDURE Save_to_File;ππVARπ Write_to_File : TEXT;π Output_to_File : STRING[20];π Read_File : BOOLEAN;π Counter : INTEGER;ππBEGINπ CLRSCR;π Jump_a_Line(3);π WRITE('PLEASE ENTER THE NAME YOU WISH TO CALLED THE FILE :=> ');π READLN(Output_to_File);π ASSIGN(Write_to_File,Output_to_File);π REWRITE(Write_to_File);π FOR Counter := 1 TO Pointer DOπ BEGINπ Writeln(Write_to_File,Stack[Counter]);π Writeln('SAVING... ',Counter:2,' ... ',Stack[Counter]);π END;π CLOSE(Write_to_File);π PressAKey;πEnd;ππ {**************************************************}ππPROCEDURE Open_A_File (StackEmpty : BOOLEAN);ππVARπ Read_File : TEXT;π Input_to_File : STRING[20];ππ BEGINπ CLRSCR;π Jump_a_Line(3);π WRITE ('PLEASE ENTER THE NAME OF THE FILE YOU WHICH TO OPENED :=> ');π READLN(Input_to_File);π ASSIGN(Read_File,Input_to_File);π {$I-}π RESET(Read_File);π IF IOResult = 0 THENπ BEGINπ Jump_a_Line(2);π Pointer := 0;π WHILE NOT EOF(Read_File) DOπ BEGINπ INC (Pointer);π READLN(Read_File,Stack [Pointer]);π WRITELN(Pointer:2,' : ',Stack[Pointer]);π END;π CLOSE(Read_File);π StackEmpty := FALSE;π ENDπ ELSEπ CLRSCR;π Jump_a_Line(2);π WRITELN (' ***********************************');π WRITELN (' *** FILE NAME DOES NOT EXIT ***');π WRITELN (' ***********************************');π {$I+}π PressAKey;πEND;ππ {****************************************************}ππPROCEDURE Menu;ππ BEGINπ gotoxy (1,10);π Textcolor(White);π WRITELN (' **************************************************');π WRITELN (' **************************************************');π WRITELN (' **** A : Add to Stack *****');π WRITELN (' **** T : Take from Stack *****');π WRITELN (' **** D : Display Stack List to Screen *****');π WRITELN (' **** P : Print Stack List *****');π WRITELN (' **** I : Initialise Stack List *****');π WRITELN (' **** S : Save Stack to disk *****');π WRITELN (' **** L : Load Stack from disk *****');π WRITELN (' **** Q : Quit program *****');π WRITELN (' **************************************************');π WRITELN (' **************************************************');π WRITELN;π WRITELN;π WRITELN (' PLEASE ENTER AN OPTION >> ');π Choice := READKEY;ππ END;ππPROCEDURE QuitProgram;ππBEGINπ gotoxy (1,10);π WRITELN (' ***********************************');π WRITELN (' """""""""""""""""""""""""""""""""""');π WRITELN (' [[[[[ GOODBYE!!!!!! ]]]]] ');π WRITELN (' """""""""""""""""""""""""""""""""""');π WRITELN (' ***********************************');π WRITELN;π WRITELN;πEND;ππ {*******************************************************************}π {*******************************************************************}ππBEGINπ Introduction;π Initialise (StackFull, StackEmpty);π REPEATπ Menu;π CLRSCR;π CASE Choice OFπ 'A', 'a' : Add (StackFull, StackEmpty);π 'T', 't' : Take (StackFull, StackEmpty);π 'D', 'd' : Display_to_Screen (StackEmpty);π 'P', 'p' : Print_to_Printer (StackEmpty);π 'I', 'i' : Initialise (StackFull, StackEmpty);π 'S', 's' : Save_to_File;π 'L', 'l' : Open_a_File(StackEmpty);π 'Q', 'q' : QuitProgramπ ELSEπ BEGINπ gotoxy (1,10);π WRITELN (' **************************');π WRITELN (' ** Invalid key pressed **');π WRITELN (' **************************');π WRITELN;π PressAKey;π END;π END;π UNTIL (Choice = 'Q') OR (Choice = 'q');πEND.π 12 08-26-9408:32ALL SWAG SUPPORT TEAM Binary Tree Example SWAG9408
┐╫· 44 ╙═ PROGRAM BinaryTreeSample ( INPUT, OUTPUT );ππUSES Crt;ππTYPE NodePtr = ^Node;ππ Node = RECORDπ Left,π Parent,π Right : WORD;π KeyWord : POINTER; { Will hold in STRING format }π END; { Where 1st byte is length }ππ Comparison = (Less, Greater, Equal);πππVAR NewWord : STRING; { Holds word typed in }π StartMem : LONGINT; { Holds starting memory }π Counter, { Used for FOR Loop }π LastNode : WORD; { Holds last node stored }π BTree : ARRAY[1..16000] OF NodePtr; { Entire Binary Tree }ππππFUNCTION PtrStr ( Ptr : POINTER ) : STRING; { Ptr --> String conversion }ππVAR Str : STRING;ππBEGINπ Move( Ptr^, Str, Mem[Seg(Ptr^):Ofs(Ptr^)]+1 ); { +1 to copy count byte }π PtrStr := Str;πEND;πππPROCEDURE Destroy ( VAR P : POINTER );πBEGINπ FreeMem (P,Mem[Seg(P^):Ofs(P^)]+1); { Dispose ptr to free mem }πEND;πππFUNCTION Compare( Ptr1, { Compares two ptrs like }π Ptr2 : POINTER ) : Comparison; { strings, returning: <, }π { >, or = }πVAR Str1,π Str2 : STRING;π Result : Comparison;ππBEGINπ Move( Ptr1^, Str1, Mem[Seg(Ptr1^):Ofs(Ptr1^)]+1 );π Move( Ptr2^, Str2, Mem[Seg(Ptr2^):Ofs(Ptr2^)]+1 );π IF Str1=Str2 THENπ Result := Equalπ ELSEπ IF Str1>Str2 THENπ Result := Greaterπ ELSEπ Result := Less;π Compare := Result;πEND;πππPROCEDURE Str_To_Pointer ( Str : STRING; { Converts Str to Ptr }π VAR Ptr : POINTER );ππBEGINπ GetMem(Ptr,Ord(Str[0])+1);π Move (Str,Ptr^,Ord(Str[0])+1);πEND;πππPROCEDURE PlaceWord ( Str : STRING ); { Sort through binary tree, and if }π { the word does not exist, add the }πVAR NewNode : Node; { node to the binary tree }π Index : WORD;π Found,π SearchFinished : BOOLEAN;π Comp : Comparison;ππBEGINπ SearchFinished := (LastNode=0);π Found := FALSE;π Index := 1;π WITH NewNode DO { Constructs initial full node }π BEGINπ Left := 0; { Don't know yet }π Right := 0; { " " " }π Parent := 0; { " " " }π Str_To_Pointer ( Str, KeyWord ); { This should store the word in ^ }π END;π IF SearchFinished THENπ BEGINπ Inc(LastNode); { Increase LastNode +1 }π New(BTree[LastNode]); { Create next node }π BTree[LastNode]^ := NewNode; { Store new node now }π END;π WHILE NOT (SearchFinished OR Found) DOπ BEGINπ Comp := Compare(NewNode.Keyword,BTree[Index]^.KeyWord);π IF Comp=EQUAL THENπ Found := TRUEπ ELSEπ IF Comp=Less THENπ BEGINπ IF BTree[Index]^.Left = 0 THEN { IF Last branch then }π BEGIN { .. lets make a new one }π Inc(LastNode); { Increase LastNode +1 }π New(BTree[LastNode]); { Create next node }π BTree[Index]^.Left := LastNode; { Point left to next node }π NewNode.Parent := Index; { Set parent to index }π BTree[LastNode]^ := NewNode; { Store new node now }π SearchFinished := TRUE { All finished! }π ENDπ ELSEπ Index := BTree[Index]^.Leftπ ENDπ ELSE { Must be greater then }π BEGINπ IF BTree[Index]^.Right = 0 THEN { IF Last branch then.. }π BEGIN { .. lets make a new one }π Inc(LastNode); { Increase LastNode +1 }π New(BTree[LastNode]); { Create next node }π BTree[Index]^.Right := LastNode; { Point left to next node }π NewNode.Parent := Index; { Set parent to index }π BTree[LastNode]^ := NewNode; { Store new node now }π SearchFinished := TRUE { All finished! }π ENDπ ELSEπ Index := BTree[Index]^.Rightπ END;π END;πEND;ππPROCEDURE Init;πBEGINπ LastNode := 0;πEND;πππPROCEDURE DisposeAll;ππVAR Counter : WORD;ππBEGINπ FOR Counter := 1 TO LastNode DOπ BEGINπ Destroy(BTree[Counter]^.KeyWord);π Dispose(BTree[Counter]);π ENDπEND;πππBEGINπ ClrScr;π StartMem := MemAvail;π Init;π REPEATπ Write ('Insert new word ["stop" to finish] : ');π Readln (NewWord);π IF NewWord <> 'stop' THENπ PlaceWord ( NewWord );π UNTIL NewWord='stop';π Writeln;π Writeln (' Node Left Parent Right Word');π Writeln ('-----------------------------------------------');π FOR Counter := 1 TO LastNode DOπ WITH BTree[Counter]^ DOπ Writeln (Counter:5,Left:8,Parent:11,Right:10,' ',PtrStr(KeyWord));π Writeln;π Writeln ('Initial memory availible : ',StartMem);π Writeln ('Memory availible before dispose : ',MemAvail);π DisposeAll;π Writeln ('Memory availible after clean-up : ',MemAvail);π Readln;πEND.π
